home *** CD-ROM | disk | FTP | other *** search
/ Collection of Tools & Utilities / Collection of Tools and Utilities.iso / pascal / tptc17sc.zip / TPCMISC.INC < prev    next >
Text File  |  1988-03-26  |  4KB  |  198 lines
  1.  
  2. (*
  3.  * TPTC - Turbo Pascal to C translator
  4.  *
  5.  * (C) 1988 Samuel H. Smith (rev. 13-Feb-88)
  6.  *
  7.  *)
  8.  
  9.  
  10. (********************************************************************)
  11. procedure mark_time(var long: longint);
  12.    {report time in clock ticks since midnight}
  13. var
  14.    words:   record
  15.                l,h: word;
  16.             end   absolute long;
  17.    reg:     registers;
  18.    
  19. begin
  20.    reg.ah := 0;  {get time of day}
  21.    intr($1a,reg);
  22.    words.l := reg.dx;
  23.    words.h := reg.cx;
  24. end;
  25.  
  26.  
  27. (********************************************************************)
  28. procedure abortcheck;
  29.    {check for the abort(escape) key}
  30. var
  31.    c:  char;
  32. begin
  33.    if keypressed then
  34.    begin
  35.       c := readkey;
  36.       if c = #27 then
  37.          fatal('Aborted by <escape> key');
  38.    end;
  39. end;
  40.  
  41.  
  42. (********************************************************************)
  43. procedure puttok;
  44.    {output the current token and a space to the output}
  45. begin
  46.    write(ofd[unitlevel],ltok,' ');
  47.    linestart := false;
  48. end;
  49.  
  50.  
  51. (********************************************************************)
  52. procedure putline;
  53.    {start a new line in the output file}
  54. begin
  55.    writeln(ofd[unitlevel]);
  56.    inc(objtotal);
  57.    linestart := true;
  58. end;
  59.  
  60.  
  61. (********************************************************************)
  62. procedure closing_statistics;
  63. var
  64.    secs: real;
  65.    rate: real;
  66.  
  67. begin
  68.  
  69.    {terminate any active output files}
  70.    if in_interface then
  71.       pimplementation;
  72.    purgetable(locals,nil);
  73.    while unitlevel > 0 do
  74.       exit_procdef;
  75.    putline;
  76.    putline;
  77.    purgetable(globals,nil);
  78.    close(ofd[unitlevel]);
  79.  
  80.    {determine statistics}
  81.    mark_time(curtime);
  82.    secs := int(curtime-starttime) / ticks_per_second;
  83.  
  84.    {rate := int(srctotal) / secs * 60.0;}
  85.    rate := int(objtotal) / secs * 60.0;
  86.    
  87.    {report statistics}
  88.    if debug then writeln;
  89.    writeln(^M,srcfiles[srclevel],'(',srclines[srclevel],')');
  90.    writeln(srctotal,' source lines, ',
  91.            objtotal,' object lines, ',
  92.            secs:0:1,' seconds, ',
  93.            rate:0:0,' lines/min.');
  94. end;
  95.  
  96.  
  97. (********************************************************************)
  98. procedure error_message (message:       string);
  99.    {place an error message into the object file and on the screen}
  100.  
  101.    procedure report(var fd: text);
  102.    begin
  103.       writeln(fd,'/* TPTC: ',srcfiles[srclevel],'(',srclines[srclevel],'): ', 
  104.            message,', tok=', ltok,' */');
  105.    end;
  106.  
  107. begin
  108.    if debug then writeln
  109.    else write(^M);
  110.    report(output);
  111.  
  112.    putline;
  113.    report(ofd[unitlevel]);
  114.    write(ofd[unitlevel],spaces);
  115.    inc(objtotal);
  116. end;
  117.  
  118.  
  119. (********************************************************************)
  120. procedure comment_statement;
  121. begin
  122.    puts(' /* ');
  123.  
  124.    repeat
  125.       puttok;
  126.       gettok;
  127.    until (tok[1] = ';');
  128.  
  129.    puts(' */ ');
  130. end;
  131.  
  132.  
  133. (********************************************************************)
  134. procedure warning (message:       string);
  135.    {report a warning message unless warnings are disabled}
  136. begin
  137.    if not quietmode then
  138.       error_message('Warning: '+message);
  139. end;
  140.  
  141.  
  142. (********************************************************************)
  143. procedure syntax (message:       string);
  144.    {report a syntax error and skip to the next ';'}
  145. begin
  146.    if (not recovery) or (not quietmode) then
  147.       error_message('Error: '+message);
  148.    gettok;
  149.    recovery := true;
  150. end;
  151.  
  152.  
  153. (********************************************************************)
  154. procedure fatal (message:       string);
  155.    {abort translation with a fatal error}
  156. begin
  157.    error_message('Fatal: '+message);
  158.    closing_statistics;
  159.    halt(88);
  160. end;
  161.  
  162.  
  163. (********************************************************************)
  164. procedure puts(s: string);
  165.    {output a string the output file}
  166. begin
  167.    write(ofd[unitlevel],s);
  168.    if s[1] = ^J then
  169.    begin
  170.       inc(objtotal);
  171.       linestart := true;
  172.    end
  173.    else
  174.       linestart := false;
  175. end;
  176.  
  177.  
  178. (********************************************************************)
  179. procedure putln(s: string);
  180.    {output a string the output file and newline}
  181. begin
  182.    puts(s);
  183.    putline;
  184. end;
  185.  
  186.  
  187. (********************************************************************)
  188. procedure newline;
  189.    {start a new line in the output file;  indent to the same level
  190.     as the current line}
  191. begin
  192.    putline;
  193.    write(ofd[unitlevel],spaces);
  194. end;
  195.  
  196.  
  197.  
  198.